home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
tptc17sc.zip
/
TPCDECL.INC
< prev
next >
Wrap
Text File
|
1988-03-26
|
17KB
|
728 lines
(*
* TPTC - Turbo Pascal to C translator
*
* (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
*
*)
(********************************************************************)
(*
* process pascal data type specifications
*
*)
function psimpletype: string80;
{parse a simple (single keyword and predefined) type; returns the
translated type specification; sets the current data type}
var
sym: symptr;
begin
if debug_parse then write(' <simpletype>');
sym := locatesym(ltok);
if sym <> nil then
begin
curtype := sym^.symtype;
if cursuptype = ss_none then
cursuptype := sym^.suptype;
curlimit := sym^.limit;
curbase := sym^.base;
curpars := sym^.parcount;
end;
psimpletype := usetok;
end;
(********************************************************************)
procedure pdatatype(stoclass: anystring;
var vars: paramlist;
prefix: anystring;
suffix: anystring;
addsemi: boolean);
{parse any full data type specification; input is a list of variables
to be declared with this data type; stoclass is a storage class prefix
(usually 'static ', '', 'typedef ', or 'extern '. prefix and suffix
are variable name modifiers used in pointer and subscript translations;
recursive for complex data types}
const
forward_typedef: anystring = '';
forward_undef: anystring = '';
var
i: integer;
ts: anystring;
ex: anystring;
sym: symptr;
nbase: integer;
bbase: integer;
nsuper: supertypes;
procedure pvarlist;
var
i: integer;
pcnt: integer;
begin
ts := '';
pcnt := -1;
if tok = 'ABSOLUTE' then
begin
if debug_parse then write(' <abs>');
gettok; {consume the ABSOLUTE}
ts := pexpr; {get the absolute lvalue}
if tok[1] = ':' then {absolute addressing}
begin
gettok;
ts := ' = MK_FP('+ts+','+pexpr+')';
end
else {variable aliasing}
begin
if ts[1] = '*' then
ts := ' = ' + copy(ts,2,255)
else
ts := ' = &(' + ts + ')';
end;
{convert new variable into a pointer if needed}
if length(prefix) = 0 then
prefix := '*';
{force automatic pointer dereference in expressions}
pcnt := -2;
end;
if cursuptype = ss_none then
cursuptype := ss_scalar;
for i := 1 to vars.n do
begin
newsym(vars.id[i],curtype,cursuptype,pcnt,withlevel,curlimit,nbase);
puts(prefix+vars.id[i]+suffix+ts);
if i < vars.n then
puts(', ');
end;
end;
procedure parray;
begin
if debug_parse then write(' <array>');
gettok; {consume the ARRAY}
repeat
gettok; {consume the [ or ,}
ts := pexpr; {consume the lower subscript expression}
if isnumber(ts) then
nbase := atoi(ts)
else
nbase := curbase;
if tok = '..' then
begin
gettok; {consume the ..}
ts := pexpr;
subtract_base(ts,nbase-1);
end
else
begin {subscript by typename - look up type range}
sym := locatesym(ts);
if sym <> nil then
begin
nbase := sym^.base;
if (sym^.limit > 0) and (sym^.suptype <> ss_const) then
ts := ' /* ' + ts + ' */ ' + itoa(sym^.limit-nbase+1);
end;
end;
suffix := suffix + '[' + ts + ']';
until tok[1] <> ',';
gettok; {consume the ]}
gettok; {consume the OF}
cursuptype := ss_array;
end;
procedure pstring;
begin
if debug_parse then write(' <string>');
gettok; {consume the STRING}
if tok[1] = '[' then
begin
gettok; {consume the [}
nsuper := cursuptype;
ts := pexpr;
cursuptype := nsuper;
subtract_base(ts,-1); {increment string size by one}
suffix := suffix + '[' + ts + ']';
gettok; {consume the ]}
end
else
suffix := suffix + '[STRSIZ]';
puts(ljust(stoclass+'char',identlen));
curtype := s_string;
nbase := 1;
pvarlist;
end;
procedure ptext;
begin
if debug_parse then write(' <text>');
gettok; {consume the TEXT}
if tok[1] = '[' then
begin
gettok; {consume the [}
nsuper := cursuptype;
ts := pexpr;
cursuptype := nsuper;
gettok; {consume the ]}
end;
puts(ljust(stoclass+'text',identlen));
curtype := s_file;
pvarlist;
end;
procedure pfile;
begin
if debug_parse then write(' <file>');
gettok; {consume the FILE}
if tok = 'OF' then
begin
gettok; {consume the OF}
ts := tok;
gettok; {consume the recordtype}
ts := '/* file of '+ts+' */ ';
end
else
ts := '/* untyped file */ ';
puts(ljust(stoclass+'int',identlen)+ts);
curtype := s_file;
pvarlist;
end;
procedure pset;
begin
if debug_parse then write(' <set>');
gettok; {consume the SET}
gettok; {consume the OF}
ts := '/* ';
if toktype = identifier then
ts := ts + usetok
else
if tok = '(' then
begin
repeat
ts := ts + usetok
until (tok[1] = ')') or recovery;
ts := ts + usetok;
end
else
ts := ts + psetof;
puts(ljust(stoclass+'setrec',identlen)+ts+' */ ');
curtype := s_struct;
pvarlist;
end;
procedure pvariant;
begin
if debug_parse then write(' <variant>');
gettok; {consume the CASE}
ts := ltok;
gettok; {consume the selector identifier}
if tok[1] = ':' then
begin
gettok; {consume the :}
puts(ltok+' '+ts+ '; /* Selector */');
gettok; {consume the selector type}
end
else
puts(' /* Selector is '+ts+' */');
gettok;
puts('union { ');
newline;
while (tok <> '}') and not recovery do
begin
ts := pexpr; {parse the selector constant}
while tok[1] = ',' do
begin
gettok;
ts := pexpr;
end;
gettok; {consume the :}
puts(' struct { ');
ts := 's' + ts;
decl_prefix := 'v.'+ts+'.';
pvar;
decl_prefix := '';
gettok; {consume the ')'}
puts(' } '+ts+';');
{arrange for reference translation}
newsym(ts,s_void,ss_struct,-1,0,0,0);
cursym^.repid := ts;
if tok[1] = ';' then
gettok;
end;
puts(' } v;');
newline;
end;
procedure precord;
begin
if debug_parse then write(' <record>');
puts(stoclass+'struct '+vars.id[1]+' { ');
inc(withlevel);
pvar; {process each record member}
if tok = 'CASE' then {process the variant part, if any}
pvariant;
dec(withlevel);
puttok; {output the closing brace}
gettok; {and consume it}
curtype := s_struct;
cursuptype := ss_struct;
pvarlist; {output any variables of this record type}
{convert a #define into a typedef in case of a forward pointer decl}
if length(forward_typedef) > 0 then
begin
puts(';');
newline;
puts(forward_undef);
n